home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1992 June: ROMin Holiday / ADC Developer CD (1992-06) (''ROMin Holiday'')_iso / Developer Connection - 06-1992.iso / Development Platforms / LISP Related / U. Mass AI & LISP Tools / MODULES / DACTN / DACTNS.lisp < prev   
Encoding:
Text File  |  1990-06-24  |  16.8 KB  |  384 lines  |  [TEXT/CCL ]
  1. ; (c) Copyright 1990 by University of Massachusetts. All rights reserved.
  2. ; This software was conceived, designed, and written by Dan Suthers 
  3. ; while supported by the National Science Foundation under grant number
  4. ; MDR 8751362, and by a fellowship from Apple Computer, Inc., Cupertino,
  5. ; CA.  Partial support was also received from the Office of Naval Research
  6. ; under a University Research Initiative Grant, contract N00014-86-K-0764.
  7. ; Mr. Suthers created this software under his own initiative while in an 
  8. ; academic relationship with the University of Massachusetts.  The above
  9. ; copyright notice was a condition placed by University lawyers on approval
  10. ; of distribution of this software by Apple Computer, and is not meant to
  11. ; imply that this software was created in an employment or "work for hire"
  12. ; relationship between the University and Mr. Suthers.
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14. ; File:         DACTNS.lisp
  15. ; Author:       Dan Suthers
  16. ; Created:      08-Aug-88 20:49:25
  17. ; Modified:     22-Jun-90 02:37:09 (Dan Suthers)
  18. ; Language:     Common Lisp
  19. ; Package:      DACTN
  20. ;
  21. ; Description:  Defines recursive DACTNs and interpreter.
  22. ;
  23. ; (c) Copyright 1988, by Daniel D. Suthers
  24. ;                        Department of Computer and Information Science
  25. ;                        University of Massachusetts
  26. ;                        Amherst, Massachusetts 01003
  27. ;
  28. ; This software was conceived, designed, and written by Dan Suthers 
  29. ; while supported by the National Science Foundation under grant number
  30. ; MDR 8751362, and by a fellowship from Apple Computer, Inc., Cupertino,
  31. ; CA.  Partial support was also received from the Office of Naval Research
  32. ; under a University Research Initiative Grant, contract N00014-86-K-0764.
  33. ; I wish to acknowledge the generous support of Beverly Woolf, who obtained 
  34. ; the above grants and encouraged me to pursue my own research interests in
  35. ; her lab.  This work would not have been possible without the resources and
  36. ; stimulating environment of the Computer and Information Science department.
  37. ;
  38. ; Permission to use, modify, and distribute this software is granted subject 
  39. ; to the following restrictions and understandings:
  40. ; 1. The file header, including this notice, shall be retained, and may be
  41. ;    extended to include documentation of modifications to the software.
  42. ; 2. This material is for nonprofit educational and research purposes only.
  43. ;    Users are requested, but not required, to inform Mr. Suthers of any 
  44. ;    noteworthy uses of this software.
  45. ; 3. Mr. Suthers and the University of Massachusetts make no warrantee or
  46. ;    representation that the operation of this software will be error free,
  47. ;    and are under no obligation to provide any services.
  48. ; 4. Any user of such software agrees to indemnify and hold harmless Mr.
  49. ;    Suthers and the University of Massachusetts from all claims arising 
  50. ;    out of the use or misuse of this software, or arising out of any 
  51. ;    accident, injury, or damage whatsoever, and from all costs, counsel
  52. ;    fees, and liabilities incurred in or about any such claim, action, or
  53. ;    proceeding brought thereon.
  54. ; 5. All materials and reports developed as a consequence of the use of 
  55. ;    this software shall duly acknowledge such use, in accordance with
  56. ;    the usual standards of acknowledging credit in academic research.
  57. ;
  58. ; Status:       Usable, though I'd do it differently now.
  59. ;               Needs compiler, better handling of re-entrant DACTNs.
  60. ;
  61. ; Changes:      
  62. ;   04-Sep-88 Interpreter does not try to interpret DACTN with no start node.
  63. ;   26-Oct-88 Interpreter signals cerror if start node is specified but not
  64. ;     defined in dactn-nodes; trace indented.
  65. ;   01-Nov-88 Updated for SM changes.
  66. ;   20-Dec-88 Added :edit-in-package :user to DST's.
  67. ;
  68. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  69. ; Comments
  70. ; 
  71. ; Nodes and arcs do not exist independently of the containing DACTN, so 
  72. ; they are not represented as separate SM objects.  In contrast, the tests
  73. ; on the arcs may be reused across DACTNs (they constitute a terminology
  74. ; for the conditional predicates), so are represented as DACTN-TESTs.  Ditto
  75. ; for the actions.
  76. ;
  77. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  78.  
  79. (in-package :DACTN)
  80.  
  81. (export '(
  82.           *trace-dactns*
  83.  
  84.           dactn
  85.           initialize-dactns
  86.           initialize-dactn
  87.           interpret-dactn
  88.           run-dactn
  89.  
  90.           dactn-test
  91.           initialize-dactn-test
  92.  
  93.           dactn-action
  94.           initialize-dactn-action
  95.  
  96.           ))
  97.  
  98. (require :SM)
  99.  
  100. ;;; To get past ccl compiler bug: it seems to hit sm:symbols before
  101. ;;; executing the require that creates the package, and gives a "no
  102. ;;; package WIND" error.
  103. (use-package :sm)
  104.  
  105. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  106.  
  107. (defconstant *ARC-TYPES* '(:goto :exit))
  108.  
  109. ;;; DACTN-NODEs are not implemented in SM as they conceptually  do not 
  110. ;;; exist outside of a given DACTN.  See the documentation under DACTN.
  111. ;;; ARG-GEN not compiled so the structure will not contain unreadable forms.
  112.  
  113. (defstruct (DACTN-NODE (:type list)) ; prints better to editor windows.
  114.   (ACTION           nil                                          :type list)
  115.   (ARG-GEN          '(lambda (node) (declare (ignore node)) nil) :type list)
  116.   (STATE            '(:state nil)                                :type list)
  117.   (ARCS             nil                                          :type list))
  118.  
  119.  
  120. (sm:dst (DACTN 
  121.          (:reusable nil) 
  122.          (:redefine t)
  123.          (:sort-instances t)
  124.          (:edit-in-package :user)
  125.          (:after-edit (lambda (d) (initialize-dactn d)))
  126.          (:comments "
  127.   Discourse ACTion Networks, written to work with the View Retriever.  Each
  128.   network is defined by a set of nodes, where each node consists of an action
  129.   and a set of arcs which are candidate ways to traverse out of the node.  One
  130.   node is designated the start node.  DACTNs are compiled into an efficient
  131.   function called by RUN-DACTN, but may be interpreted by INTERPRET-DACTN for 
  132.   debugging."))
  133.  
  134.         (NODES      nil
  135.                     :type list
  136.                     :comments "
  137.     An association list of node names to the definition of the node, which is
  138.     a DACTN-NODE structure.  (SM is not used for nodes because they are not 
  139.     visible outside of a given DACTN.)  The latter structure contains the
  140.     following slots:
  141.       ACTION  - (:action <action-name>) or (:dactn <dactn-name>).
  142.       ARG-GEN - Lambda of one argument which generates the arguments to be
  143.         given to the ACTION.  The argument is a list of form (:state <state>).
  144.         A setf of the second element will modify the node's state.
  145.       STATE   - A list of form (:state <state>).  Initially <state> is nil.
  146.       ARCS    - An association list of DACTN-TESTs to arcs, which are of form
  147.         (:goto <node-name>) or (:exit). Thus each entry in this list will look
  148.         like (<dactn-test-name> <arc-action-keyword> [<argument>]).  The arc
  149.         in the first one whose CAR succeeds will be traversed.
  150.     When a node is entered, (1) ARG-GEN is called on the state to generate a list
  151.     of arguments; (2) the indicated ACTION is called on these arguments; (3) the
  152.     list of ARCS is scanned to find the first one whose DACTN-TEST returns T when
  153.     called on the state value; and (4) this arc is traversed by interpreting its 
  154.     keyword.")
  155.  
  156.         (START-NODE nil
  157.                     :type symbol
  158.                     :comments "
  159.     The name of the start node for this DACTN.  Its action is always executed.
  160.     when the DACTN is run.  It must be defined in NODES.")
  161.  
  162.         (FUNCTION #'(lambda (d ns)
  163.                       (error "Uncompiled DACTN-FUNCTION given ~S and ~S." d ns))
  164.                   :type function
  165.                   :computed t
  166.                   :comments "
  167.     This is the compiled version of the DACTN, used to save the time of 
  168.     searching association lists and interpreting actions.  INITIALIZE-DACTN
  169.     fills this slot. The function takes no arguments, and executes the DACTN
  170.     when funcalled.")
  171.  
  172.         (TYPE       nil
  173.                     :type symbol
  174.                     :comments "
  175.     This is a place to put a symbol categorizing the DACTN, to aid accessing and
  176.     editing them.  The use of this slot is application specific.")
  177.  
  178.         (COMMENTS "" :type string))
  179.  
  180.  
  181. (sm:dst (DACTN-TEST
  182.          (:reusable nil)
  183.          (:redefine t)
  184.          (:sort-instances t)
  185.          (:edit-in-package :user)
  186.          (:after-edit (lambda (dt) (initialize-dactn-test dt)))
  187.          (:comments "
  188.   These are reusable tests of the state of the discourse and user models, used to
  189.   determine which arc to take in a DACTN.  They are given the current state value 
  190.   (the second element of the STATE slot) of the node as their only argument."))
  191.  
  192.         (FORM '(lambda (state) nil)
  193.               :type list
  194.               :comments "
  195.     A lambda list of one argument, the STATE, which returns T iff whatever it tests
  196.     for is true.  Presumable some of these access the discourse and user models.")
  197.  
  198.         (COMPILED-FORM #'(lambda (state)
  199.                            (error "Uncompiled DACTN-TEST-FORM given ~S" state))
  200.                        :type function
  201.                        :computed t)
  202.  
  203.         (TYPE     nil
  204.                   :type symbol
  205.                   :comments "
  206.     This is a place to put a symbol categorizing the DACTN-TEST, to aid accessing and
  207.     editing them.  The use of this slot is application specific.  See also INFO.")
  208.  
  209.         (INFO     nil 
  210.                   :comments "
  211.     This is a place to put arbitrary info about the test.  See also TYPE.")
  212.  
  213.         (COMMENTS "" :type string))
  214.  
  215.  
  216. (sm:dst (DACTN-ACTION
  217.          (:reusable nil)
  218.          (:redefine t)
  219.          (:sort-instances t)
  220.          (:edit-in-package :user)
  221.          (:after-edit (lambda (da) (initialize-dactn-action da)))
  222.          (:comments "
  223.   Each of these defines an action in the underlying application.  The names
  224.   of these objects are the arguments to the :dactn-action specifier in DACTN
  225.   arcs."))
  226.  
  227.         (FORM '(lambda (args)  nil)
  228.               :type list
  229.               :comments "
  230.     A lambda list of one argument which executes the intended action.  The
  231.     arguments are the list of arguments given to the action in the arc.")
  232.  
  233.  
  234.         (COMPILED-FORM #'(lambda (args) (error "Uncompiled DACTN-ACTION given ~S" args))
  235.                        :type function
  236.                        :computed t)
  237.  
  238.         (TYPE     nil
  239.                   :type symbol
  240.                   :comments "
  241.     This is a place to put a symbol categorizing the DACTN-ACTION, to aid accessing and
  242.     editing them.  The use of this slot is application specific.")
  243.  
  244.         (INFO     nil 
  245.                   :comments "
  246.     This is a place to put arbitrary info about the action.  See also TYPE.")
  247.  
  248.         (COMMENTS "" :type string))
  249.  
  250. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  251.  
  252. (defun INITIALIZE-DACTNS ()
  253.   (format *trace-output* "~&[Initializing DACTN-TESTs")
  254.   (dolist (dt (sm:instances 'dactn-test))
  255.     (declare (symbol dt))
  256.     (initialize-dactn-test dt))
  257.   (format *trace-output* "]~%[Initializing DACTN-ACTIONs")
  258.   (dolist (da (sm:instances 'dactn-action))
  259.     (declare (symbol da))
  260.     (initialize-dactn-action da))
  261.   (format *trace-output* "]~%[Initializing DACTNs")
  262.   (dolist (d (sm:instances 'dactn))
  263.     (declare (symbol d))
  264.     (initialize-dactn d))
  265.   (format *trace-output* "]"))
  266.  
  267. (defun INITIALIZE-DACTN-TEST (dt)
  268.   (let ((dactn-test (sm:gets 'dactn-test dt)))
  269.     (setf (dactn-test-compiled-form dactn-test)
  270.           (compile nil (dactn-test-form dactn-test)))))
  271.  
  272. (defun INITIALIZE-DACTN-ACTION (da)
  273.   (let ((dactn-action (sm:gets 'dactn-action da)))
  274.     (setf (dactn-action-compiled-form dactn-action)
  275.           (compile nil (dactn-action-form dactn-action)))))
  276.  
  277. (defun INITIALIZE-DACTN (d) nil)
  278. ;  (let ((dactn (sm:gets 'dactn d)))
  279. ;    (dolist (name+struct (dactn-nodes dactn))
  280. ;      (declare (cons name+struct))
  281. ;      (setf (dactn-compiled-chooser dactn)
  282. ;            (compile nil
  283. ;                     `(lambda ()
  284. ;                        (interpret-action
  285. ;                         (funcall (dactn-compiled-chooser (sm:gets 'dactn dactn))
  286. ;                                  (mapcan #'(lambda (t+a)
  287. ;                                              (declare (cons t+a))
  288. ;                                              (if (funcall (dactn-test-compiled-form 
  289. ;                                                            (sm:gets 'dactn-test (car t+a))))
  290. ;                                                (list t+a)))
  291. ;                                          (dactn-arcs (sm:gets 'dactn dactn))))))))))
  292.  
  293. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  294.  
  295. (defvar *TRACE-DACTNS* nil)
  296.  
  297. (defun INTERPRET-DACTN (dactn)
  298.   "interpret-dactn <dactn>                                          [Function]
  299.   Interprets the dactn, without using the compiled dactn-function.  Also
  300.   uses uncompiled DACTN-TEST-FORM, DACTN-NODE-ARG-GEN, and DACTN-ACTION-FORM.
  301.   Useful for debugging purposes."
  302.   (check-type dactn symbol)
  303.   (assert (sm:gets 'dactn dactn) (dactn) "~S is not a known DACTN." dactn)
  304.   (let* ((dactn-struct (sm:gets 'dactn dactn))
  305.          (start-node (dactn-start-node dactn-struct))
  306.          (node-struct
  307.           (cdr (assoc start-node (dactn-nodes dactn-struct)))))
  308.     (declare (type dactn dactn-struct))
  309.  
  310.     ;; This would have saved me some time if it was here earlier ...
  311.     (if (and start-node (null node-struct)) 
  312.       (cerror "Will exit the DACTN but continue execution."
  313.               "[INTERPRET-DACTN] Specified start node ~S for DACTN ~S is not defined."
  314.               start-node dactn))
  315.  
  316.     (when node-struct
  317.       (when *trace-dactns*
  318.         (if (not (numberp *trace-dactns*)) (setq *trace-dactns* 0))
  319.         (format *trace-output* "~&")
  320.         (dotimes (x *trace-dactns*) (format *trace-output* " "))
  321.         (format *trace-output* "[INTERPRET-DACTN] Starting ~A at ~A" 
  322.                 dactn (dactn-start-node dactn-struct))
  323.         (incf *trace-dactns*))
  324.  
  325.       ;; Interpretation consists of traversing arcs and interpreting nodes encountered.
  326.       ;; If an :exit arc is executed in this dactn, returns to here immediately.
  327.       (interpret-dactn-nodes dactn-struct node-struct)
  328.  
  329.       (when *trace-dactns* 
  330.         (decf *trace-dactns*)
  331.         (format *trace-output* "~&")
  332.         (dotimes (x *trace-dactns*) (format *trace-output* " "))
  333.         (format *trace-output* "[INTERPRET-DACTN] Leaving  ~A"
  334.                 dactn (dactn-start-node dactn-struct))))))
  335.  
  336. (defun INTERPRET-DACTN-NODES (dactn-struct node-struct)
  337.   (declare (type dactn dactn-struct) (type dactn-node node-struct))
  338.   ;; Loop to repeat on new dactn nodes (saving cost of recursion).
  339.   (loop
  340.     ;; Run the action of the node.
  341.     (case (first (dactn-node-action node-struct))
  342.       ((nil) (cerror "Will ignore." "Unspecified action for node ~S." node-struct))
  343.       ;; Action called on arguments generated by arg-gen, which tests & sets state.
  344.       ((:action)
  345.        (funcall (dactn-action-form (sm:gets 'dactn-action
  346.                                             (second (dactn-node-action node-struct))))
  347.                 (funcall (dactn-node-arg-gen node-struct) 
  348.                          (dactn-node-state node-struct))))
  349.       ((:dactn) (interpret-dactn (second (dactn-node-action node-struct)))))
  350.     ;; Find the first arc whose test succeeds when called on the node's state.
  351.     (let ((arc (find-if #'(lambda (arc) (declare (list arc))
  352.                            (funcall (dactn-test-form (sm:gets 'dactn-test (first arc)))
  353.                                     (dactn-node-state node-struct)))
  354.                         (dactn-node-arcs node-struct))))
  355.       ;; Traverse this arc as specified by its keyword.
  356.       (if arc
  357.         (ecase (second arc)
  358.           ;; Go To is to another node in the dactn: (<test> :goto <node>)
  359.           ((:goto)
  360.            (when *trace-dactns* 
  361.              (format *trace-output* "~&")
  362.              (dotimes (x *trace-dactns*) (format *trace-output* " "))
  363.              (format *trace-output* "[INTERPRET-DACTN-NODES] Going to node ~A" 
  364.                      (third arc)))
  365.            (setq node-struct (cdr (assoc (third arc) (dactn-nodes dactn-struct)))))
  366.           ;; Exit returns from the dactn, so requires a throw.
  367.           ((:exit) (return nil)))
  368.         (return nil)))))
  369.  
  370. ;;; Right now these parallel the INTERPRET- functions, but will be
  371. ;;; converted to simply invoke a truly compiled version, which simply:
  372. ;;;    (funcall (dactn-function (sm:gets 'dactn dactn)) dactn)
  373.  
  374. (defun RUN-DACTN (dactn)
  375.   "run-dactn <dactn>                                                [Function]
  376.   Runs the DACTN, using its compiled functions."
  377.   (check-type dactn symbol)
  378.   (assert (sm:gets 'dactn dactn) (dactn) "~S is not a known DACTN.")
  379.   (cerror "returns" "RUN-DACTN not implemented, use INTERPRET-DACTN for ~S." dactn))
  380.  
  381. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  382. (provide :DACTNS)
  383. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  384. ;;; EOF